perm filename PLTSRT.F4[MSS,LCS]11 blob
sn#138019 filedate 1974-12-30 generic text, type T, neo UTF8
00010 C SUBRS. RHORZ, SLUR, JUGGLE, LOOP, PLTSRT, LINES, RDRAW
00020
06000 FUNCTION RHORZ(R)
06100 RHORZ=R*5.96-596.
06200 END
06300
06400
06500 SUBROUTINE SLUR
06600 IMPLICIT INTEGER(A-Q,T-Z)
06610 DIMENSION SLURX(72)
06700 REAL CENTR,PWDS
06710 COMMON /XRN/RN(4000) /PLTR/PLT,RHT,RDIS
06900 COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
06950 1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
06962 1 J5,J6,J7,J8,J9,J10,J11,JQ(9)
07000 COMMON/PTR/PWDS(250),ITEM,L,I,IX /STF/RSTFAC(-3/4),RSTJ3
07010 COMMON/ALF/INP,SLURY(72)
07400 DATA RZZ/2.8/
07500 C DEFAULT VALUE OF SLUR CURVE FACTOR IS 2.8
07600
07805 IF(JA.NE.12)GO TO 2
07810 RA=5.96*RSTJ3*R5
07815 L=3
07817 J8=J8*RDIS
07820 IF(J7.LE.J6)J7=J7+360
07822 KQ=6
07823 IF(PLT)KQ=1
07825 10 DO 3 K=J6,J7,KQ
07830 R=K
07835 CALL LINES(R2+RA*SIND(R),CENTR+RA*COSD(R),L)
07840 3 L=2
07841 J8=J8-1
07842 IF(J8)RETURN
07843 RA=RA+1/RDIS
07844 GO TO 10
07845 CJA=12 DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2,P8=THICK(EXPANDS
07850 RETURN
07880
07900 2 J10=1
07901 J4=-1
07902 KQ=3
07903 TWICE=-1
07904 C -1 FOR DISPLAY, USES ONLY 1/3 OF SEGMENTS
07905 IF(PLT.GE.0)GO TO 21
07910 TWICE=0
07912 KQ=1
07915 RWID=.2
07920 IF(RHT.LT.2)GO TO 21
07925 TWICE=1
07927 RWID=.14
07928 C IF SIZE IS GT.2 3 SLURS ARE DRAWN
07930 21 RST7=RSTJ3*7.
08000 IF(R6.GT.1000)CALL RNOTE(R6)
08010 GO TO (5,6,7),J8+4
08015 GO TO 4
08020 5 R=32
08025 C AFTER DOTTED NOTE
08030 GO TO 8
08040 6 R=22
08045 C BETWEEN NOTES
08050 8 RX=-1.3
08060 GO TO 9
08070 7 R=7
08080 RX=RSTJ3
08090 9 CALL RJBX(R)
08100 R6=R6+RX
08250 4 RXX=RHORZ(R6)-R2
08260 RTILT=(R5-R4)*RST7
08270 80 RX=SQRT(RXX**2+RTILT**2)
08280 1 R=CENTR
08300 IF(J8.GT.0)GO TO 180
08400 C FOR BRACKETS
08410 RB=RX/71.
08500 DO 81 K=0,71
08600 81 SLURX(K+1)=RB*(K)+R2
08700 RA=R7*RST7
08775 41 IF(R9.EQ.0)R9=RZZ
08800 R=R+RA
08900 L=0
09000 DO 40 K=36,1,-1
09100 L=L+1
09200 RW=R-RA*(K/36.)**R9
09300 SLURY(L)=RW
09400 40 SLURY(73-L)=RW
09600 L=72
09700
09800 89 IF(RTILT.EQ.0)GO TO 87
09900 CC R=RTILT*RF
10000 RW=ATAN2(RTILT,RXX)
10100 RA=SIN(RW)
10200 RB=COS(RW)
10300 RZ=SLURX(1)
10400 RW=SLURY(1)
10500 DO 84 K=1,L
10600 SLURX(K)=SLURX(K)-RZ
10700 84 SLURY(K)=SLURY(K)-RW
10800 DO 83 K=1,L
10900 R=SLURX(K)
11000 SLURX(K)=RB*R-RA*SLURY(K)+RZ
11100 83 SLURY(K)=RB*SLURY(K)+RA*R+RW
11200
11300 87 IF(J4)CALL LINES(SLURX(J10),SLURY(J10),3)
11310 J5=KQ
11320 J6=J10
11330 J7=L
11340 IF(J4.NE.0)GO TO 22
11350 CALL EXCH(J6,J7)
11360 J5=-1
11400 22 DO 88 K=J6,J7,J5
11500 88 CALL LINES(SLURX(K),SLURY(K),2)
11505 IF(J5.GT.1)CALL LINES(SLURX(72),SLURY(72),2)
11507 C DISPLAY END POINT OF SLUR
11510 IF(TWICE)RETURN
11520 TWICE=TWICE-1
11525 J4=J4+1
11530 R7=R7+RWID
11535 C RWID=WIDTH OF SLUR -- SEE DATA
11540 GO TO 1
11700 180 RW=R+R7*RST7
11750 KQ=1
11800 RX=RX+R2
11900 RA=(R5-R4)*RST7
12000 SLURX(1)=R2
12100 SLURY(1)=R
12200 SLURX(2)=R2
12300 SLURY(2)=RW
12400 SLURX(3)=RX
12500 SLURY(3)=RW+RA
12600 SLURX(4)=RX
12700 SLURY(4)=R+RA
12800 L=4
12900 IF(J8.EQ.2)L=3
13000 IF(J8.EQ.3)J10=2
13010 TWICE=-1
13100 GO TO 87
13200 END
13300 C 8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
13400 C FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
13500
13600
13700 C******** JUGGLER ********
13800 SUBROUTINE JUGGLE
13900 IMPLICIT INTEGER(A-Z)
14000 REAL PWDS,RN
14100 COMMON /DL/X22,SAVER,NAME /XRN/RN(4000)
14200 COMMON/PTR/PWDS(250),ITEM,L,I,IX/DPY/ST(4000),WDS(250),MEDIT,IGO
14300
14400 ITEM=ITEM-1
14500 JX=RN(MEDIT)+3
14600 C WD CNT OF OLD ITEM
14700 C I-IX IS WD CNT OF NEW ITEM
14800 JY=IX
14900 Z=I-IX-JX
15000 C SPACE CHANGE
15100 IF(Z)2751,172,751
15200 751 CALL LOOP(I-1,MEDIT+JX,-1,Z,0,RN)
15300 JY=IX+Z
15400 GO TO 172
15500
15600 2751 CALL LOOP(MEDIT+JX+Z,IX+Z-1,1,0,-Z,RN)
15700
15800 172 J=RN(JY)+2
15900 CALL LOOP(0,J,1,MEDIT,JY,RN)
16000 I=IX+Z
16100
16200 1751 X=ITEM+1
16300 JX=WDS(X22+1)-WDS(X22)
16400 J=WDS(X+1)-WDS(X)
16500 Y=J-JX
16600 JX=WDS(X)+Y+1
16700 IF(Y)2851,182,282
16800 282 CALL LOOP(WDS(X+1)+2,WDS(X22),-1,Y,0,ST)
16900 GO TO 182
17000
17100 2851 CALL LOOP(WDS(X22+1)+Y+1,WDS(X)+Y+1,1,0,-Y,ST)
17200 JX=WDS(X)+1
17300
17400 182 CALL LOOP(1,J,1,WDS(X22)+1,JX,ST)
17500 DO 183 K=X22+1,X
17600 PWDS(K)=PWDS(K)+Z
17700 183 WDS(K)=WDS(K)+Y
17800 ST(2)=WDS(X)
17900 X22=0
18000 END
18100
18200
18300 SUBROUTINE LOOP(I,J,K,L,M,N)
18400 DIMENSION N(1)
18420 MM=M-L
18500 DO 1 NN=I+L,J+L,K
18600 1 N(NN)=N(NN+MM)
18700 END
19300
19400
19500 SUBROUTINE PLTSRT(M)
19600 C SORTS DATA TO SHORTEN INVISIBLE VECTORS WHEN PLOTTING.
19700 IMPLICIT INTEGER(S-Z)
19800 COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
19940 COMMON/DPY/Q(3000),P(1000),WDS(250),MEDIT,IGO
19970 C Q AND P OCCUPY DPY BUFFER. Q IS FOR OVERFLOW OF RN.
20000 DO 4 K=1,ITEM
20100 L=PWDS(K)
20150 A=RN(L+2)
20200 P(K)=A+1000*RN(L+3)
20250 4 IF(A.LT.0.OR.RN(L+1).EQ.16.)P(K)=-10000
20275 C PLOTS ALL NEG. HORIZ. POSITIONS AND WORDS(CODE 16) FIRST.
20300 M=I
20320 IF(I.LT.1500)I=1500
20340 Y=I
20360 I=I+M-1
20380 M=Y
20400 C M IS IN MAIN PROG., LEAVES 1500 WDS IN RN FOR "NOIR" DATA.
20500 2 A=P(1)
20600 L=1
20700 DO 1 K=1,ITEM
20800 IF(A.LE.P(K))GO TO 1
20900 A=P(K)
21000 L=K
21100 1 CONTINUE
21200 IF(A.EQ.10000.)RETURN
21300 C ALL ITEMS HAVE NOW BEEN SHUFFLED
21400 V=PWDS(L)
21500 P(L)=10000
21600 L=RN(V)+2
21700 CALL LOOP(0,L,1,Y,V,RN)
21800 Y=Y+L+1
21900 GO TO 2
22000 END
22100
22200
22300
22400 SUBROUTINE BOX(I,R,STFF)
22500 COMMON/SIZ/RSZ,JCEN,KCEN /XRN/RN(4000) /STF/RSTFAC(-3/4),RSTJ3
22925 DIMENSION STFF(1),N(100)
22962 EQUIVALENCE (N,RN(2901))
23000 IF(I)GO TO 4
23100 K=R
23200 K=(STFF(K+4)+AMOD(RN(I+4),100.0)*7.*RSTFAC(K)
23300 1 -40.0)*RSZ-KCEN
23350 C ↑↑↑↑ WAS -60.0 10/74
23400 C AMOD IS FOR MINI NOTES AND CLEFS
23500 L=RHORZ(RN(I+2))*RSZ-JCEN
23600 IF(IABS(L).GT.550)L=511
23700 IF(IABS(K).GT.550)K=511
23800 CC1 CALL ALINE(L,K,L+50,K)
23900 CC CALL RVECT(0,100)
24000 CC CALL RVECT(-50,0)
24100 CC CALL RVECT(0,-100)
24200 CC L=L+25
24300 CC2 CALL ALINE(L,K-25,L,K+125)
24450 CC3 CALL DPYOUT(1)
24460 CALL SETCUR(L,K,0)
24500 RETURN
24600 4 IF(I.LT.-1)GO TO 5
24700 CALL DPYSET(3,N,100)
24800 CALL DPYBRT(3)
24900 5 L=RHORZ(R)*RSZ-JCEN
25000 IF(IABS(L).GT.550)GO TO 6
25050 C DOESN'T TRY TO DRAW LINE OFF SCREEN
25100 CALL SETPOG(3)
25200 CALL ALINE(L,-511,L,511)
25300 CALL DPYOUT(3)
25400 6 CALL SETPOG(1)
25600 END
25700
25800 SUBROUTINE LINES(A,B,L)
25850 COMMON/DST/BB,CC
25900 COMMON /SIZ/RSZ,JCEN,KCEN /FL/IC,NZ,NX,RZ,XGP
26000 COMMON/DL/IXRX,SAVER,AA /PLTR/IPLT,RHT,DIS
26100 COMMON R2,JA,CENTR,JB,RJQ(20),JQ(20)
26200 COMMON/DPY/JJ(4000),WDS(250),MEDIT,IGO
26400 EQUIVALENCE (ITOP,JJ(3999)),(IBOT,JJ(4000))
26402 1,(JJ2,JJ(2))
26500 DATA BB/.008/,CC/3.5/
26600 C SET XGP TO 1200.0 FOR MARGIN IN XEROX COPIES
26650 GO TO 23
26700 22 IF(JQ(1).NE.0)GO TO 23
26750 IF(CC.EQ.1000)GO TO 23
26775 C ABOVE TO SKIP DISTORTION ON COMMAND
26800 C CHANGE ABOVE TO 'JFCL' IN DDT TO USE NEXT ITEMS.
27000 C USE THIS IN DDT TO DISTORT ITEMS. CC MUST BE > DD
27100 B=B*(CC-BB*ABS(A))
27150 C CC IS HGT FACTOR.
27200 23 IF(IPLT)GO TO 2
27300 M=A*RSZ
27400 N=B*RSZ
27500 IF(RSZ.LE.0.8571)GO TO 3
27600 C NEXT FOR DISPLAY MAGNIFICATION
27700 M=M-JCEN
27800 N=N-KCEN
27900 IF(JA.NE.10)GO TO 5
28000 C NEXT INSURES DISPLAY OF STAFF LINES
28100 IF(M.GT.511)M=511
28200 IF(M.LT.-511)M=-511
28400 5 IF(IABS(M).LT.512.AND.IABS(N).LT.512)GO TO 4
28500 C NOW DRAWS INVISIBLE VECT. IF IT GOES OFF THE SCREEN.
28600 KZ=-1
28700 RETURN
28800 4 IF(KZ.EQ.0)GO TO 6
28900 KZ=0
29000 GO TO 1
29050 3 IF(JA.EQ.44)GO TO 6
29075 C JA=44=BAR LINES - THEY DON'T FIGURE IN MAX. HGT.
29100 K=B
29200 IF(K.GT.ITOP)ITOP=B
29300 IF(K.LT.IBOT)IBOT=B
29302 6 IF(JJ2.GT.3990)RETURN
29400 IF(L.EQ.3)GO TO 1
29500 CALL AVECT(M,N)
29600 RETURN
29700 1 CALL AIVECT(M,N)
29800 RETURN
29900 2 IF(IPLT.EQ.-2)RETURN
30300 C RXGP SETS UP-DOWN POS. ON XEROX PAPER (FRACTIONAL POSITIONS POSSIBLE.)
30400 CC IF(B)BX=-BX
30500 C AX AND BX ARE FOR ROUND-OFF
30600 CC IF(IXRX.EQ.0)GO TO 9
30610 CC M=ROFF(RXGP-B*RHT)
30620 CC N=ROFF(XGP+A*DIS)
30900 CC GO TO 8
31110 9 M=ROFF(A*DIS)
31120 N=ROFF(B*RHT)
31200 8 CALL PLOT(M,N,L)
31400 END
31540
31600 SUBROUTINE RDRAW(I,S,XY,X,R2,CENTR,RMINI)
31700 C TO X,Y INTO ONE WORD
31800 DIMENSION XY(1)
31900 DO 2 K=I,IFIX(S)
32000 L=2
32100 Y=XY(K)
32200 IF(Y.LT.1000.)GO TO 3
32300 L=3
32400 Y=Y-1000.
32500 C >1000 = INVIS. LINE
32600 3 M=Y
32700 Y=(Y-M)*1000.
32800 IF(Y.GT.100.)Y=100-Y
32900 C Y NUMBERS .GT.100 ARE NEG.
33000 B=Y*X+CENTR
33100 IF(M.GT.60)M=100-M
33200 A=M*RMINI+R2
33300 2 CALL LINES(A,B,L)
33500 END